home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 090 / cmln0786.arc / GRAFTAL2.LTG < prev    next >
Text File  |  1986-03-31  |  9KB  |  281 lines
  1.  
  2. Graftals Listing 2
  3.  
  4. program graftal3;
  5. { 3-D version of graftals }
  6. { Program by Ken Birdwell and Steve Estvanik }
  7. const
  8.   max_segments = 10000;
  9. type
  10.   bytearray  = array [0..max_segments] of byte;
  11.   codearray  = array [0..7,0..20] of byte;
  12.   realarray = array [0..10] of real;
  13.   rotarray = array[0..2,0..2,0..49] of real;
  14. var
  15.     code      : codearray;
  16.     graftal   : bytearray;
  17.     x_ang     : realarray;
  18.     y_ang     : realarray;
  19.     scale     : real;
  20.     room_left : boolean;
  21.     graftal_len, gen, num_gen, num_ang, ang_mod, i, j : integer;
  22. procedure getcode(var num_var : integer;
  23.                   var code : codearray;
  24.                   var x_ang : realarray;
  25.                   var y_ang : realarray;
  26.                   var num_ang : integer;
  27.                   var ang_mod : integer );
  28.   var key : string[20];
  29.       d, g, num_x_ang, num_y_ang : integer;
  30.   begin
  31.     write('Enter number of generations: ');
  32.     readln(num_gen);
  33.     for d := 0 to 7 do
  34.       begin
  35.         write('Enter key for ',d :1, ':  ');
  36.         readln(key);
  37.         code[d,0] := length(key);
  38.         for g := 1 to code[d,0] do
  39.           case key[g] of
  40.             '0' : code[d,g] := 0;
  41.             '1' : code[d,g] := 1;
  42.             '[' : code[d,g] := 128;
  43.             ']' : code[d,g] := 64;
  44.           end;
  45.       end;
  46.     write('Enter number of Y axis angles: ');
  47.     readln(num_y_ang);
  48.     for g := 1 to num_y_ang do
  49.       begin
  50.         write ('Enter angle (deg) ', g : 2, ': ');
  51.         readln(i);
  52.         y_ang[g] := i*3.1415/180;
  53.       end;
  54.     write('Enter number of X axis angles: ');
  55.     readln(num_x_ang);è    for g := 1 to num_x_ang do
  56.       begin
  57.         write ('Enter angle (deg) ', g : 2, ': ');
  58.         readln(i);
  59.         x_ang[g] := i*3.1415/180;
  60.       end;
  61.     ang_mod := num_x_ang;
  62.     num_ang := num_x_ang * num_y_ang;
  63.   end;
  64. function findnext(p : integer;
  65.                    var orig : bytearray;
  66.                    var orig_len : integer ) : integer ;
  67. var
  68.     found : boolean;
  69.     depth : integer;
  70.     begin
  71.        depth := 0;
  72.        found := FALSE;
  73.        while (p < orig_len) and not found
  74.           begin
  75.              p := p + 1;
  76.              if (depth = 0) and (orig[p] < 2 ) then
  77.                 begin
  78.                   findnext := orig[p];
  79.                   found := TRUE;
  80.                 end
  81.              else if ((depth = 0) and ((orig[p] and 64) <> 0)) then
  82.                 begin
  83.                    findnext := 1;
  84.                    found := TRUE;
  85.                 end
  86.              else if (orig[p] and 128) <> 0 then
  87.                   depth := depth + 1
  88.              else if (orig[p] and 64) <> 0 then
  89.                   depth := depth - 1;
  90.            end;
  91.         if (not found) then
  92.             findnext := 1;
  93.     end;
  94. procedure add_new(b2, b1, b0 : integer;
  95.                   var dest : bytearray;
  96.                   var code : codearray;
  97.                   var dest_len : integer;
  98.                   num_ang : integer );
  99.     var d, i : integer;
  100.     begin
  101.       d := b2 * 4 + b1 * 2 + b0;
  102.       for i := 1 to code[d, 0] do
  103.         begin
  104.         dest_len := dest_len + 1;
  105.         case code[d,i] of
  106.            0..63 : dest[dest_len] := code[d,i];
  107.            64    : dest[dest_len] := 64;
  108.            128   : dest[dest_len] := 128 + random(num_ang);
  109.            end;è        end;
  110.     end;
  111. procedure generation (var orig : bytearray;
  112.                       var orig_len : integer;
  113.                       var code : codearray );
  114.     var depth, dest_len,g,a : integer ;
  115.         b0,b1,b2            : byte ;
  116.         stack               : array [0..50] of integer;
  117.         dest                : bytearray;
  118.     begin
  119.         depth := 0;
  120.         dest_len := 0;
  121.         b2 := 1;
  122.         b1 := 1;
  123.         for g := 1 to orig_len do
  124.             begin
  125.             if (orig[g] < 2) then
  126.                begin
  127.                b2 := b1;
  128.                b1 := orig[g];
  129.                b0 := findnext(g, orig, orig_len);
  130.                add_new(b2, b1, b0, dest, code, dest_len, num_ang) ;
  131.                end
  132.             else if (orig[g] and 128) <> 0 then
  133.                begin
  134.                dest_len := dest_len + 1;
  135.                dest[dest_len] := orig[g];
  136.                depth := depth + 1;
  137.                stack[depth] := b1;
  138.                end
  139.             else if (orig[g] and 64) <>0 then
  140.                begin
  141.                dest_len := dest_len + 1;
  142.                dest[dest_len] := orig[g];
  143.                b1 := stack[depth];
  144.                depth := depth - 1;
  145.                end;
  146.             end;
  147.         for a := 1 to dest_len do
  148.             orig[a] := dest[a];
  149.         orig_len := dest_len;
  150.     end;
  151. procedure print_generation(var graftal : bytearray;
  152.                            var graftal_len : integer);
  153.     var p : integer;
  154.     begin
  155.         writeln('');
  156.         for p := 1 to graftal_len do
  157.             begin
  158.             if (graftal[p] < 2)          then write(graftal[p]:1);
  159.             if (graftal[p] and 128) <> 0 then write('[');
  160.             if (graftal[p] and 64)  <> 0 then write(']');
  161.             end;
  162.         writeln('');
  163.     end;èprocedure calc_rotational_matrix(xangle, yangle : real;
  164.                                  depth : integer;
  165.                                  var rot3 : rotarray );
  166.     var sinx, siny : real;
  167.     var cosx, cosy : real;
  168.     var r_d        : real;
  169.     begin
  170.         sinx := sin(xangle);
  171.         cosx := cos(xangle);
  172.         siny := sin(yangle);
  173.         cosy := cos(yangle);
  174.         rot3[0,0,depth] := cosy;
  175.         rot3[0,1,depth] := -sinx * -siny;
  176.         rot3[0,2,depth] := cosx * -siny;
  177.         rot3[1,0,depth] := 0;
  178.         rot3[1,1,depth] := cosx;
  179.         rot3[1,2,depth] := sinx;
  180.         rot3[2,0,depth] := siny;
  181.         rot3[2,1,depth] := -sinx * cosy;
  182.         rot3[2,2,depth] := cosx * cosy;
  183.     end;
  184. procedure calc_deltas(var dx, dy, dz : real;
  185.                       depth : integer;
  186.                       rot3 : rotarray );
  187.         var x, y, z : real;
  188.         d : integer;
  189.     begin
  190.         dx := 0;
  191.         dy := -1;
  192.         dz := 0;
  193.         for d := depth downto 0 do
  194.             begin
  195.             x  := dx;
  196.             y  := dy;
  197.             z  := dz;
  198.             dx := x * rot3[0,0,d] + y * rot3[0,1,d] + z * rot3[0,2,d];
  199.             dy := x * rot3[1,0,d] + y * rot3[1,1,d] + z * rot3[1,2,d];
  200.             dz := x * rot3[2,0,d] + y * rot3[2,1,d] + z * rot3[2,2,d];
  201.             end;
  202.     end;
  203. procedure draw_generation (var graftal : bytearray;
  204.                            var graftal_len : integer;
  205.                            var x_ang : realarray;
  206.                            var y_ang : realarray;
  207.                            var ang_mod : integer;
  208.                            scale : real );
  209.     var a_xp, a_yp, a_zp : array[0..50] of real;
  210.         a_dx, a_dy, a_dz : array[0..50] of real;
  211.         xp, yp, zp       : real;
  212.         dx, dy, dz       : real;
  213.         g, depth, ra     : integer;
  214.         rot3             : rotarray;
  215.     begin
  216.         graphcolormode;
  217.         xp := 140;è        yp := 180;
  218.         zp := 0;
  219.         dx := 0;
  220.         dy := -1;
  221.         dz := 0;
  222.         gotoxy(1,1);
  223.         write('Gen ',gen);
  224.         depth := 0;
  225.         calc_rotational_matrix(0,1.570795,depth,rot3);
  226.         for g := 1 to graftal_len do
  227.             begin
  228.             if (graftal[g] < 2) then
  229.                begin
  230.                { drop shadow }
  231.                {draw (round(xp)-1, round(yp)-1,
  232.                       round(xp+dx*scale-1),round(yp+dy*scale-1),0);}
  233.                draw (round(xp), round(yp),
  234.                      round(xp+dx*scale), round(yp+dy*scale),
  235.                      graftal[g]*2+1);
  236.                xp := xp + dx * scale;
  237.                yp := yp + dy * scale;
  238.                zp := zp + dz * scale;
  239.                end;
  240.                if (graftal[g] and 128) <> 0 then
  241.                    begin
  242.                    a_xp[depth] := xp;
  243.                    a_yp[depth] := yp;
  244.                    a_zp[depth] := zp;
  245.                    a_dx[depth] := dx;
  246.                    a_dy[depth] := dy;
  247.                    a_dz[depth] := dz;
  248.                    depth := depth + 1;
  249.                    ra := (graftal[g] and $7f);
  250.                    calc_rotational_matrix(x_ang[(ra mod ang_mod)+1],
  251.                                           y_ang[(ra div ang_mod)+1],
  252.                                           depth,rot3);
  253.                    calc_deltas(dx,dy,dz,depth,rot3);
  254.                    end;
  255.  
  256.                if (graftal[g] and 64) <> 0 then
  257.                    begin
  258.                    depth := depth - 1;
  259.                    xp := a_xp[depth];
  260.                    yp := a_yp[depth];
  261.                    zp := a_zp[depth];
  262.                    dx := a_dx[depth];
  263.                    dy := a_dy[depth];
  264.                    dz := a_dz[depth];
  265.                    end;
  266.             end;
  267.     end;
  268. begin
  269.     getcode(num_gen, code, x_ang, y_ang, num_ang, ang_mod);
  270.     graftal_len := 1;
  271.     graftal[graftal_len] := 1;è    scale := 4;
  272.     for gen := 1 to num_gen do
  273.        begin
  274.        generation(graftal, graftal_len, code);
  275.        draw_generation(graftal, graftal_len, x_ang, y_ang, ang_mod, scale);
  276.        {print_generation(graftal, graftal_len);}
  277.        end;
  278.     readln(i);
  279. end.
  280.  
  281.